--- /dev/null
+unit gnugettext;\r
+(**************************************************************)\r
+(* *)\r
+(* (C) Copyright by Lars B. Dybdahl and others *)\r
+(* E-mail: Lars@dybdahl.dk, phone +45 70201241 *)\r
+(* File version: $Date: 2005-09-28 00:33:08 $ *)\r
+(* Revision: $Revision: 1.1 $ *)\r
+(* *)\r
+(* Contributors: Peter Thornqvist, Troy Wolbrink, *)\r
+(* Frank Andreas de Groot, Igor Siticov, *)\r
+(* Jacques Garcia Vazquez *)\r
+(* *)\r
+(* See http://dybdahl.dk/dxgettext/ for more information *)\r
+(* *)\r
+(**************************************************************)\r
+\r
+// Redistribution and use in source and binary forms, with or without\r
+// modification, are permitted provided that the following conditions are met:\r
+//\r
+// The names of any contributor may not be used to endorse or promote\r
+// products derived from this software without specific prior written permission.\r
+//\r
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"\r
+// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\r
+// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\r
+// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE\r
+// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\r
+// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\r
+// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\r
+// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\r
+// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+\r
+interface\r
+\r
+// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.\r
+// Use DefaultInstance.DebugLogToFile() to write the log to a file.\r
+{ $define DXGETTEXTDEBUG}\r
+\r
+{$ifdef VER100}\r
+ // Delphi 3\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+{$endif}\r
+{$ifdef VER110}\r
+ // C++ Builder 3\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+{$endif}\r
+{$ifdef VER120}\r
+ // Delphi 4\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+{$endif}\r
+{$ifdef VER125}\r
+ // C++ Builder 4\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+{$endif}\r
+{$ifdef VER130}\r
+ // Delphi 5\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+ {$ifdef WIN32}\r
+ {$DEFINE MSWINDOWS}\r
+ {$endif}\r
+{$endif}\r
+{$ifdef VER135}\r
+ // C++ Builder 5\r
+ {$DEFINE DELPHI5OROLDER}\r
+ {$DEFINE DELPHI6OROLDER}\r
+ {$ifdef WIN32}\r
+ {$DEFINE MSWINDOWS}\r
+ {$endif}\r
+{$endif}\r
+{$ifdef VER140}\r
+ // Delphi 6\r
+{$ifdef MSWINDOWS}\r
+ {$DEFINE DELPHI6OROLDER}\r
+{$endif}\r
+{$endif}\r
+{$ifdef VER150}\r
+ // Delphi 7\r
+{$endif}\r
+\r
+uses\r
+{$ifdef DELPHI5OROLDER}\r
+ gnugettextD4, \r
+{$endif}\r
+\r
+{$ifdef MSWINDOWS}\r
+ Windows,\r
+{$else}\r
+ Libc,\r
+{$endif}\r
+ Classes, SysUtils, TypInfo;\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* MAIN API *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+// Main GNU gettext functions. See documentation for instructions on how to use them.\r
+function _(const szMsgId: widestring): widestring;\r
+function gettext(const szMsgId: widestring): widestring;\r
+function dgettext(const szDomain: string; const szMsgId: widestring): widestring;\r
+function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;\r
+function ngettext(const singular,plural: widestring; Number:longint): widestring;\r
+procedure textdomain(const szDomain: string);\r
+function getcurrenttextdomain: string;\r
+procedure bindtextdomain(const szDomain: string; const szDirectory: string);\r
+\r
+// Set language to use\r
+procedure UseLanguage(LanguageCode: string);\r
+function GetCurrentLanguage:string;\r
+\r
+// Translates a component (form, frame etc.) to the currently selected language.\r
+// Put TranslateComponent(self) in the OnCreate event of all your forms.\r
+// See the manual for documentation on these functions\r
+type\r
+ TTranslator=procedure (obj:TObject) of object;\r
+\r
+procedure TP_Ignore(AnObject:TObject; const name:string);\r
+procedure TP_IgnoreClass (IgnClass:TClass);\r
+procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);\r
+procedure TP_GlobalIgnoreClass (IgnClass:TClass);\r
+procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);\r
+procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r
+procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+\r
+// Add more domains that resourcestrings can be extracted from. If a translation\r
+// is not found in the default domain, this domain will be searched, too.\r
+// This is useful for adding mo files for certain runtime libraries and 3rd\r
+// party component libraries\r
+procedure AddDomainForResourceString (const domain:string);\r
+procedure RemoveDomainForResourceString (const domain:string);\r
+\r
+// Unicode-enabled way to get resourcestrings, automatically translated\r
+// Use like this: ws:=LoadResStringW(@NameOfResourceString);\r
+function LoadResString(ResStringRec: PResStringRec): widestring;\r
+function LoadResStringA(ResStringRec: PResStringRec): ansistring;\r
+function LoadResStringW(ResStringRec: PResStringRec): widestring;\r
+\r
+// This returns an empty string if not translated or translator name is not specified.\r
+function GetTranslatorNameAndEmail:widestring;\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* ADVANCED FUNCTIONALITY *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+const\r
+ DefaultTextDomain = 'default';\r
+\r
+var\r
+ ExecutableFilename:string; // This is set to paramstr(0) or the name of the DLL you are creating.\r
+\r
+type\r
+ EGnuGettext=class(Exception);\r
+ EGGProgrammingError=class(EGnuGettext);\r
+ EGGComponentError=class(EGnuGettext);\r
+ EGGIOError=class(EGnuGettext);\r
+ EGGAnsi2WideConvError=class(EGnuGettext);\r
+\r
+// This function will turn resourcestring hooks on or off, eventually with BPL file support.\r
+// Please do not activate BPL file support when the package is in design mode.\r
+const AutoCreateHooks=true;\r
+procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* CLASS based implementation. *)\r
+(* Use TGnuGettextInstance to have more than one language *)\r
+(* in your application at the same time *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+{$ifdef MSWINDOWS}\r
+{$ifndef DELPHI6OROLDER}\r
+{$WARN UNSAFE_TYPE OFF}\r
+{$WARN UNSAFE_CODE OFF}\r
+{$WARN UNSAFE_CAST OFF}\r
+{$endif}\r
+{$endif}\r
+\r
+type\r
+ TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object; // Set Discard to false if output should still go to ordinary debug log\r
+ TGetPluralForm=function (Number:Longint):Integer;\r
+ TDebugLogger=procedure (line: ansistring) of object;\r
+ TMoFile= // Don't use this class. It's for internal use.\r
+ class // Threadsafe. Only constructor and destructor are writing to memory\r
+ private\r
+ doswap: boolean;\r
+ public\r
+ Users:Integer; // Reference count. If it reaches zero, this object should be destroyed.\r
+ constructor Create (filename:string;Offset,Size:int64);\r
+ destructor Destroy; override;\r
+ function gettext(const msgid: ansistring;var found:boolean): ansistring; // uses mo file\r
+ property isSwappedArchitecture:boolean read doswap;\r
+ private\r
+ N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html\r
+ startindex,startstep:integer;\r
+ {$ifdef mswindows}\r
+ mo: THandle;\r
+ momapping: THandle;\r
+ {$endif}\r
+ momemoryHandle:PChar;\r
+ momemory: PChar;\r
+ function autoswap32(i: cardinal): cardinal;\r
+ function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;\r
+ end;\r
+ TDomain= // Don't use this class. It's for internal use.\r
+ class\r
+ private\r
+ Enabled:boolean;\r
+ vDirectory: string;\r
+ procedure setDirectory(const dir: string);\r
+ public\r
+ DebugLogger:TDebugLogger;\r
+ Domain: string;\r
+ property Directory: string read vDirectory write setDirectory;\r
+ constructor Create;\r
+ destructor Destroy; override;\r
+ // Set parameters\r
+ procedure SetLanguageCode (const langcode:string);\r
+ procedure SetFilename (const filename:string); // Bind this domain to a specific file\r
+ // Get information\r
+ procedure GetListOfLanguages(list:TStrings);\r
+ function GetTranslationProperty(Propertyname: string): WideString;\r
+ function gettext(const msgid: ansistring): ansistring; // uses mo file\r
+ private\r
+ mofile:TMoFile;\r
+ SpecificFilename:string;\r
+ curlang: string;\r
+ OpenHasFailedBefore: boolean;\r
+ procedure OpenMoFile;\r
+ procedure CloseMoFile;\r
+ end;\r
+ TExecutable=\r
+ class\r
+ procedure Execute; virtual; abstract;\r
+ end;\r
+ TGnuGettextInstance=\r
+ class\r
+ private\r
+ fOnDebugLine:TOnDebugLine;\r
+ CreatorThread:Cardinal; // Only this thread can use LoadResString\r
+ public\r
+ Enabled:Boolean; // Set this to false to disable translations\r
+ DesignTimeCodePage:Integer; // See MultiByteToWideChar() in Win32 API for documentation\r
+ constructor Create;\r
+ destructor Destroy; override;\r
+ procedure UseLanguage(LanguageCode: string);\r
+ procedure GetListOfLanguages (const domain:string; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list\r
+ {$ifdef DELPHI5OROLDER}\r
+ function gettext(const szMsgId: widestring): widestring;\r
+ function ngettext(const singular,plural:widestring;Number:longint):widestring;\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ function gettext(const szMsgId: ansistring): widestring; overload;\r
+ function gettext(const szMsgId: widestring): widestring; overload;\r
+ function ngettext(const singular,plural:ansistring;Number:longint):widestring; overload;\r
+ function ngettext(const singular,plural:widestring;Number:longint):widestring; overload;\r
+ {$endif}\r
+ function GetCurrentLanguage:string;\r
+ function GetTranslationProperty (const Propertyname:string):WideString;\r
+ function GetTranslatorNameAndEmail:widestring;\r
+\r
+ // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()\r
+ procedure TP_Ignore(AnObject:TObject; const name:string);\r
+ procedure TP_IgnoreClass (IgnClass:TClass);\r
+ procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:string);\r
+ procedure TP_GlobalIgnoreClass (IgnClass:TClass);\r
+ procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);\r
+ procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r
+ procedure TranslateProperties(AnObject: TObject; textdomain:string='');\r
+ procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+ procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+\r
+ // Multi-domain functions\r
+ {$ifdef DELPHI5OROLDER}\r
+ function dgettext(const szDomain: string; const szMsgId: widestring): widestring;\r
+ function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring;\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ function dgettext(const szDomain: string; const szMsgId: ansistring): widestring; overload;\r
+ function dgettext(const szDomain: string; const szMsgId: widestring): widestring; overload;\r
+ function dngettext(const szDomain: string; const singular,plural:ansistring;Number:longint):widestring; overload;\r
+ function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring; overload;\r
+ {$endif}\r
+ procedure textdomain(const szDomain: string);\r
+ function getcurrenttextdomain: string;\r
+ procedure bindtextdomain(const szDomain: string; const szDirectory: string);\r
+ procedure bindtextdomainToFile (const szDomain: string; const filename: string); // Also works with files embedded in exe file\r
+\r
+ // Windows API functions\r
+ function LoadResString(ResStringRec: PResStringRec): widestring;\r
+\r
+ // Output all log info to this file. This may only be called once.\r
+ procedure DebugLogToFile (const filename:string; append:boolean=false);\r
+ procedure DebugLogPause (PauseEnabled:boolean);\r
+ property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here\r
+\r
+ // Conversion according to design-time character set\r
+ function ansi2wide (const s:ansistring):widestring;\r
+ protected\r
+ procedure TranslateStrings (sl:TStrings;const TextDomain:string);\r
+\r
+ // Override these three, if you want to inherited from this class\r
+ // to create a new class that handles other domain and language dependent\r
+ // issues\r
+ procedure WhenNewLanguage (const LanguageID:string); virtual; // Override to know when language changes\r
+ procedure WhenNewDomain (const TextDomain:string); virtual; // Override to know when text domain changes. Directory is purely informational\r
+ procedure WhenNewDomainDirectory (const TextDomain,Directory:string); virtual; // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file.\r
+ private\r
+ curlang: string;\r
+ curGetPluralForm:TGetPluralForm;\r
+ curmsgdomain: string;\r
+ savefileCS: TMultiReadExclusiveWriteSynchronizer;\r
+ savefile: TextFile;\r
+ savememory: TStringList;\r
+ DefaultDomainDirectory:string;\r
+ domainlist: TStringList; // List of domain names. Objects are TDomain.\r
+ TP_IgnoreList:TStringList; // Temporary list, reset each time TranslateProperties is called\r
+ TP_ClassHandling:TList; // Items are TClassMode. If a is derived from b, a comes first\r
+ TP_GlobalClassHandling:TList; // Items are TClassMode. If a is derived from b, a comes first\r
+ TP_Retranslator:TExecutable; // Cast this to TTP_Retranslator\r
+ DebugLogCS:TMultiReadExclusiveWriteSynchronizer;\r
+ DebugLog:TStream;\r
+ DebugLogOutputPaused:Boolean;\r
+ function TP_CreateRetranslator:TExecutable; // Must be freed by caller!\r
+ procedure FreeTP_ClassHandlingItems;\r
+ procedure DebugWriteln(line: ansistring);\r
+ procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;\r
+ TodoList: TStrings; const TextDomain:string);\r
+ function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain; // Translates a single property of an object\r
+ end;\r
+\r
+var\r
+ DefaultInstance:TGnuGettextInstance;\r
+\r
+// DELPHI 4\r
+\r
+function GetStrProp(Instance: TObject; const Name: string): string; overload;\r
+function GetStrProp(Instance: TObject; Info: PPropInfo): string; overload;\r
+\r
+procedure SetStrProp(Instance: TObject; const Name, Value: string); overload;\r
+procedure SetStrProp(Instance: TObject; Info: PPropInfo; const Value: string); overload;\r
+\r
+implementation\r
+\r
+(**************************************************************************)\r
+// Some comments on the implementation:\r
+// This unit should be independent of other units where possible.\r
+// It should have a small footprint in any way.\r
+(**************************************************************************)\r
+// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection\r
+// because it makes this unit independent of the SyncObjs unit\r
+(**************************************************************************)\r
+\r
+{$ifdef DELPHI5OROLDER}\r
+uses\r
+ FileCtrl;\r
+{$endif}\r
+\r
+type\r
+ TTP_RetranslatorItem=\r
+ class\r
+ obj:TObject;\r
+ Propname:string;\r
+ OldValue:WideString;\r
+ end;\r
+ TTP_Retranslator=\r
+ class (TExecutable)\r
+ TextDomain:string;\r
+ Instance:TGnuGettextInstance;\r
+ constructor Create;\r
+ destructor Destroy; override;\r
+ procedure Remember (obj:TObject; PropName:String; OldValue:WideString);\r
+ procedure Execute; override;\r
+ private\r
+ list:TList;\r
+ end;\r
+ TEmbeddedFileInfo=\r
+ class\r
+ offset,size:int64;\r
+ end;\r
+ TFileLocator=\r
+ class // This class finds files even when embedded inside executable\r
+ constructor Create;\r
+ destructor Destroy; override;\r
+ procedure Analyze; // List files embedded inside executable\r
+ function FileExists (filename:string):boolean;\r
+ function GetMoFile (filename:string;DebugLogger:TDebugLogger):TMoFile;\r
+ procedure ReleaseMoFile (mofile:TMoFile);\r
+ private\r
+ basedirectory:string;\r
+ filelist:TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file\r
+ MoFilesCS:TMultiReadExclusiveWriteSynchronizer;\r
+ MoFiles:TStringList; // Objects are filenames+offset, objects are TMoFile\r
+ function ReadInt64 (str:TStream):int64;\r
+ end;\r
+ TGnuGettextComponentMarker=\r
+ class (TComponent)\r
+ public\r
+ LastLanguage:string;\r
+ Retranslator:TExecutable;\r
+ destructor Destroy; override;\r
+ end;\r
+ TClassMode=\r
+ class\r
+ HClass:TClass;\r
+ SpecialHandler:TTranslator;\r
+ PropertiesToIgnore:TStringList; // This is ignored if Handler is set\r
+ constructor Create;\r
+ destructor Destroy; override;\r
+ end;\r
+ TRStrinfo = record\r
+ strlength, stroffset: cardinal;\r
+ end;\r
+ TStrInfoArr = array[0..10000000] of TRStrinfo;\r
+ PStrInfoArr = ^TStrInfoArr;\r
+ TCharArray5=array[0..4] of ansichar;\r
+ THook= // Replaces a runtime library procedure with a custom procedure\r
+ class\r
+ public\r
+ constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);\r
+ destructor Destroy; override; // Restores unhooked state\r
+ procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again\r
+ procedure Disable;\r
+ procedure Enable;\r
+ private\r
+ oldproc,newproc:Pointer;\r
+ Patch:TCharArray5;\r
+ Original:TCharArray5;\r
+ PatchPosition:PChar;\r
+ procedure Shutdown; // Same as destroy, except that object is not destroyed\r
+ end;\r
+\r
+var\r
+ // System information\r
+ Win32PlatformIsUnicode:boolean=False;\r
+ \r
+ // Information about files embedded inside .exe file\r
+ FileLocator:TFileLocator;\r
+\r
+ // Hooks into runtime library functions\r
+ ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer;\r
+ ResourceStringDomainList:TStringList;\r
+ HookLoadResString:THook;\r
+ HookLoadStr:THook;\r
+ HookFmtLoadStr:THook;\r
+\r
+function GGGetEnvironmentVariable(const Name:string):string;\r
+var\r
+ Len: integer;\r
+ W : String;\r
+begin\r
+ Result := '';\r
+ SetLength(W,1);\r
+ Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(W), 1);\r
+ if Len > 0 then begin\r
+ SetLength(Result, Len - 1);\r
+ Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);\r
+ end;\r
+end;\r
+\r
+function StripCR (s:string):string;\r
+var\r
+ i:integer;\r
+begin\r
+ i:=1;\r
+ while i<=length(s) do begin\r
+ if s[i]=#13 then delete (s,i,1) else inc (i);\r
+ end;\r
+ Result:=s;\r
+end;\r
+\r
+function LF2LineBreakA (s:string):string;\r
+{$ifdef MSWINDOWS}\r
+var\r
+ i:integer;\r
+{$endif}\r
+begin\r
+ {$ifdef MSWINDOWS}\r
+ Assert (sLinebreak=#13#10);\r
+ i:=1;\r
+ while i<=length(s) do begin\r
+ if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin\r
+ insert (#13,s,i);\r
+ inc (i,2);\r
+ end else\r
+ inc (i);\r
+ end;\r
+ {$endif}\r
+ Result:=s;\r
+end;\r
+\r
+function IsWriteProp(Info: PPropInfo): Boolean;\r
+begin\r
+ Result := Assigned(Info) and (Info^.SetProc <> nil);\r
+end;\r
+\r
+function string2csyntax(s: string): string;\r
+// Converts a string to the syntax that is used in .po files\r
+var\r
+ i: integer;\r
+ c: char;\r
+begin\r
+ Result := '';\r
+ for i := 1 to length(s) do begin\r
+ c := s[i];\r
+ case c of\r
+ #32..#33, #35..#255: Result := Result + c;\r
+ #13: Result := Result + '\r';\r
+ #10: Result := Result + '\n"'#13#10'"';\r
+ #34: Result := Result + '\"';\r
+ else\r
+ Result := Result + '\0x' + IntToHex(ord(c), 2);\r
+ end;\r
+ end;\r
+ Result := '"' + Result + '"';\r
+end;\r
+\r
+function ResourceStringGettext(MsgId: widestring): widestring;\r
+var\r
+ i:integer;\r
+begin\r
+ if (MsgID='') or (ResourceStringDomainListCS=nil) then begin\r
+ // This only happens during very complicated program startups that fail,\r
+ // or when Msgid=''\r
+ Result:=MsgId;\r
+ exit;\r
+ end;\r
+ ResourceStringDomainListCS.BeginRead;\r
+ try\r
+ for i:=0 to ResourceStringDomainList.Count-1 do begin\r
+ Result:=dgettext(ResourceStringDomainList.Strings[i], MsgId);\r
+ if Result<>MsgId then\r
+ break;\r
+ end;\r
+ finally\r
+ ResourceStringDomainListCS.EndRead;\r
+ end;\r
+end;\r
+\r
+function gettext(const szMsgId: widestring): widestring;\r
+begin\r
+ Result:=DefaultInstance.gettext(szMsgId);\r
+end;\r
+\r
+function _(const szMsgId: widestring): widestring;\r
+begin\r
+ Result:=DefaultInstance.gettext(szMsgId);\r
+end;\r
+\r
+function dgettext(const szDomain: string; const szMsgId: widestring): widestring;\r
+begin\r
+ Result:=DefaultInstance.dgettext(szDomain, szMsgId);\r
+end;\r
+\r
+function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;\r
+begin\r
+ Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);\r
+end;\r
+\r
+function ngettext(const singular,plural: widestring; Number:longint): widestring;\r
+begin\r
+ Result:=DefaultInstance.ngettext(singular,plural,Number);\r
+end;\r
+\r
+procedure textdomain(const szDomain: string);\r
+begin\r
+ DefaultInstance.textdomain(szDomain);\r
+end;\r
+\r
+procedure SetGettextEnabled (enabled:boolean);\r
+begin\r
+ DefaultInstance.Enabled:=enabled;\r
+end;\r
+\r
+function getcurrenttextdomain: string;\r
+begin\r
+ Result:=DefaultInstance.getcurrenttextdomain;\r
+end;\r
+\r
+procedure bindtextdomain(const szDomain: string; const szDirectory: string);\r
+begin\r
+ DefaultInstance.bindtextdomain(szDomain, szDirectory);\r
+end;\r
+\r
+procedure TP_Ignore(AnObject:TObject; const name:string);\r
+begin\r
+ DefaultInstance.TP_Ignore(AnObject, name);\r
+end;\r
+\r
+procedure TP_GlobalIgnoreClass (IgnClass:TClass);\r
+begin\r
+ DefaultInstance.TP_GlobalIgnoreClass(IgnClass);\r
+end;\r
+\r
+procedure TP_IgnoreClass (IgnClass:TClass);\r
+begin\r
+ DefaultInstance.TP_IgnoreClass(IgnClass);\r
+end;\r
+\r
+procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);\r
+begin\r
+ DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname);\r
+end;\r
+\r
+procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);\r
+begin\r
+ DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);\r
+end;\r
+\r
+procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r
+begin\r
+ DefaultInstance.TP_GlobalHandleClass (HClass, Handler);\r
+end;\r
+\r
+procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+begin\r
+ DefaultInstance.TranslateComponent(AnObject, TextDomain);\r
+end;\r
+\r
+procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');\r
+begin\r
+ DefaultInstance.RetranslateComponent(AnObject, TextDomain);\r
+end;\r
+\r
+{$ifdef MSWINDOWS}\r
+\r
+// These constants are only used in Windows 95\r
+// Thanks to Frank Andreas de Groot for this table\r
+const\r
+ IDAfrikaans = $0436; IDAlbanian = $041C;\r
+ IDArabicAlgeria = $1401; IDArabicBahrain = $3C01;\r
+ IDArabicEgypt = $0C01; IDArabicIraq = $0801;\r
+ IDArabicJordan = $2C01; IDArabicKuwait = $3401;\r
+ IDArabicLebanon = $3001; IDArabicLibya = $1001;\r
+ IDArabicMorocco = $1801; IDArabicOman = $2001;\r
+ IDArabicQatar = $4001; IDArabic = $0401;\r
+ IDArabicSyria = $2801; IDArabicTunisia = $1C01;\r
+ IDArabicUAE = $3801; IDArabicYemen = $2401;\r
+ IDArmenian = $042B; IDAssamese = $044D;\r
+ IDAzeriCyrillic = $082C; IDAzeriLatin = $042C;\r
+ IDBasque = $042D; IDByelorussian = $0423;\r
+ IDBengali = $0445; IDBulgarian = $0402;\r
+ IDBurmese = $0455; IDCatalan = $0403;\r
+ IDChineseHongKong = $0C04; IDChineseMacao = $1404;\r
+ IDSimplifiedChinese = $0804; IDChineseSingapore = $1004;\r
+ IDTraditionalChinese = $0404; IDCroatian = $041A;\r
+ IDCzech = $0405; IDDanish = $0406;\r
+ IDBelgianDutch = $0813; IDDutch = $0413;\r
+ IDEnglishAUS = $0C09; IDEnglishBelize = $2809;\r
+ IDEnglishCanadian = $1009; IDEnglishCaribbean = $2409;\r
+ IDEnglishIreland = $1809; IDEnglishJamaica = $2009;\r
+ IDEnglishNewZealand = $1409; IDEnglishPhilippines = $3409;\r
+ IDEnglishSouthAfrica = $1C09; IDEnglishTrinidad = $2C09;\r
+ IDEnglishUK = $0809; IDEnglishUS = $0409;\r
+ IDEnglishZimbabwe = $3009; IDEstonian = $0425;\r
+ IDFaeroese = $0438; IDFarsi = $0429;\r
+ IDFinnish = $040B; IDBelgianFrench = $080C;\r
+ IDFrenchCameroon = $2C0C; IDFrenchCanadian = $0C0C;\r
+ IDFrenchCotedIvoire = $300C; IDFrench = $040C;\r
+ IDFrenchLuxembourg = $140C; IDFrenchMali = $340C;\r
+ IDFrenchMonaco = $180C; IDFrenchReunion = $200C;\r
+ IDFrenchSenegal = $280C; IDSwissFrench = $100C;\r
+ IDFrenchWestIndies = $1C0C; IDFrenchZaire = $240C;\r
+ IDFrisianNetherlands = $0462; IDGaelicIreland = $083C;\r
+ IDGaelicScotland = $043C; IDGalician = $0456;\r
+ IDGeorgian = $0437; IDGermanAustria = $0C07;\r
+ IDGerman = $0407; IDGermanLiechtenstein = $1407;\r
+ IDGermanLuxembourg = $1007; IDSwissGerman = $0807;\r
+ IDGreek = $0408; IDGujarati = $0447;\r
+ IDHebrew = $040D; IDHindi = $0439;\r
+ IDHungarian = $040E; IDIcelandic = $040F;\r
+ IDIndonesian = $0421; IDItalian = $0410;\r
+ IDSwissItalian = $0810; IDJapanese = $0411;\r
+ IDKannada = $044B; IDKashmiri = $0460;\r
+ IDKazakh = $043F; IDKhmer = $0453;\r
+ IDKirghiz = $0440; IDKonkani = $0457;\r
+ IDKorean = $0412; IDLao = $0454;\r
+ IDLatvian = $0426; IDLithuanian = $0427;\r
+ IDMacedonian = $042F; IDMalaysian = $043E;\r
+ IDMalayBruneiDarussalam = $083E; IDMalayalam = $044C;\r
+ IDMaltese = $043A; IDManipuri = $0458;\r
+ IDMarathi = $044E; IDMongolian = $0450;\r
+ IDNepali = $0461; IDNorwegianBokmol = $0414;\r
+ IDNorwegianNynorsk = $0814; IDOriya = $0448;\r
+ IDPolish = $0415; IDBrazilianPortuguese = $0416;\r
+ IDPortuguese = $0816; IDPunjabi = $0446;\r
+ IDRhaetoRomanic = $0417; IDRomanianMoldova = $0818;\r
+ IDRomanian = $0418; IDRussianMoldova = $0819;\r
+ IDRussian = $0419; IDSamiLappish = $043B;\r
+ IDSanskrit = $044F; IDSerbianCyrillic = $0C1A;\r
+ IDSerbianLatin = $081A; IDSesotho = $0430;\r
+ IDSindhi = $0459; IDSlovak = $041B;\r
+ IDSlovenian = $0424; IDSorbian = $042E;\r
+ IDSpanishArgentina = $2C0A; IDSpanishBolivia = $400A;\r
+ IDSpanishChile = $340A; IDSpanishColombia = $240A;\r
+ IDSpanishCostaRica = $140A; IDSpanishDominicanRepublic = $1C0A;\r
+ IDSpanishEcuador = $300A; IDSpanishElSalvador = $440A;\r
+ IDSpanishGuatemala = $100A; IDSpanishHonduras = $480A;\r
+ IDMexicanSpanish = $080A; IDSpanishNicaragua = $4C0A;\r
+ IDSpanishPanama = $180A; IDSpanishParaguay = $3C0A;\r
+ IDSpanishPeru = $280A; IDSpanishPuertoRico = $500A;\r
+ IDSpanishModernSort = $0C0A; IDSpanish = $040A;\r
+ IDSpanishUruguay = $380A; IDSpanishVenezuela = $200A;\r
+ IDSutu = $0430; IDSwahili = $0441;\r
+ IDSwedishFinland = $081D; IDSwedish = $041D;\r
+ IDTajik = $0428; IDTamil = $0449;\r
+ IDTatar = $0444; IDTelugu = $044A;\r
+ IDThai = $041E; IDTibetan = $0451;\r
+ IDTsonga = $0431; IDTswana = $0432;\r
+ IDTurkish = $041F; IDTurkmen = $0442;\r
+ IDUkrainian = $0422; IDUrdu = $0420;\r
+ IDUzbekCyrillic = $0843; IDUzbekLatin = $0443;\r
+ IDVenda = $0433; IDVietnamese = $042A;\r
+ IDWelsh = $0452; IDXhosa = $0434;\r
+ IDZulu = $0435;\r
+\r
+function GetWindowsLanguage: string;\r
+var\r
+ langid: Cardinal;\r
+ langcode: string;\r
+ CountryName: array[0..4] of char;\r
+ LanguageName: array[0..4] of char;\r
+ works: boolean;\r
+begin\r
+ // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero\r
+ works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));\r
+ works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,\r
+ SizeOf(CountryName)));\r
+ if works then begin\r
+ // Windows 98, Me, NT4, 2000, XP and newer\r
+ LangCode := PChar(@LanguageName[0]);\r
+ if lowercase(LangCode)='no' then LangCode:='nb';\r
+ LangCode:=LangCode + '_' + PChar(@CountryName[0]);\r
+ end else begin\r
+ // This part should only happen on Windows 95.\r
+ langid := GetThreadLocale;\r
+ case langid of\r
+ IDBelgianDutch: langcode := 'nl_BE';\r
+ IDBelgianFrench: langcode := 'fr_BE';\r
+ IDBrazilianPortuguese: langcode := 'pt_BR';\r
+ IDDanish: langcode := 'da_DK';\r
+ IDDutch: langcode := 'nl_NL';\r
+ IDEnglishUK: langcode := 'en_GB';\r
+ IDEnglishUS: langcode := 'en_US';\r
+ IDFinnish: langcode := 'fi_FI';\r
+ IDFrench: langcode := 'fr_FR';\r
+ IDFrenchCanadian: langcode := 'fr_CA';\r
+ IDGerman: langcode := 'de_DE';\r
+ IDGermanLuxembourg: langcode := 'de_LU';\r
+ IDGreek: langcode := 'el_GR';\r
+ IDIcelandic: langcode := 'is_IS';\r
+ IDItalian: langcode := 'it_IT';\r
+ IDKorean: langcode := 'ko_KO';\r
+ IDNorwegianBokmol: langcode := 'nb_NO';\r
+ IDNorwegianNynorsk: langcode := 'nn_NO';\r
+ IDPolish: langcode := 'pl_PL';\r
+ IDPortuguese: langcode := 'pt_PT';\r
+ IDRussian: langcode := 'ru_RU';\r
+ IDSpanish, IDSpanishModernSort: langcode := 'es_ES';\r
+ IDSwedish: langcode := 'sv_SE';\r
+ IDSwedishFinland: langcode := 'sv_FI';\r
+ else\r
+ langcode := 'C';\r
+ end;\r
+ end;\r
+ Result := langcode;\r
+end;\r
+{$endif}\r
+\r
+function LoadResStringA(ResStringRec: PResStringRec): string;\r
+begin\r
+ Result:=DefaultInstance.LoadResString(ResStringRec);\r
+end;\r
+\r
+function GetTranslatorNameAndEmail:widestring;\r
+begin\r
+ Result:=DefaultInstance.GetTranslatorNameAndEmail;\r
+end;\r
+\r
+procedure UseLanguage(LanguageCode: string);\r
+begin\r
+ DefaultInstance.UseLanguage(LanguageCode);\r
+end;\r
+\r
+type\r
+ PStrData = ^TStrData;\r
+ TStrData = record\r
+ Ident: Integer;\r
+ Str: string;\r
+ end;\r
+ \r
+function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean;\r
+{$IFDEF MSWINDOWS}\r
+var\r
+ Buffer: array [0..1023] of char;\r
+begin\r
+ with PStrData(Data)^ do begin\r
+ SetString(Str, Buffer,\r
+ LoadString(Instance, Ident, Buffer, sizeof(Buffer)));\r
+ Result := Str = '';\r
+ end;\r
+end;\r
+{$ENDIF}\r
+{$IFDEF LINUX}\r
+var\r
+ rs:TResStringRec;\r
+ Module:HModule;\r
+begin\r
+ Module:=Instance;\r
+ rs.Module:=@Module;\r
+ with PStrData(Data)^ do begin\r
+ rs.Identifier:=Ident;\r
+ Str:=System.LoadResString(@rs);\r
+ Result:=Str='';\r
+ end;\r
+end;\r
+{$ENDIF}\r
+\r
+function SysUtilsFindStringResource(Ident: Integer): string;\r
+var\r
+ StrData: TStrData;\r
+begin\r
+ StrData.Ident := Ident;\r
+ StrData.Str := '';\r
+ EnumResourceModules(SysUtilsEnumStringModules, @StrData);\r
+ Result := StrData.Str;\r
+end;\r
+\r
+function SysUtilsLoadStr(Ident: Integer): string;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called');\r
+ {$endif}\r
+ Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));\r
+end;\r
+\r
+function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called');\r
+ {$endif}\r
+ FmtStr(Result, SysUtilsFindStringResource(Ident), Args);\r
+ Result:=ResourceStringGettext(Result);\r
+end;\r
+\r
+function LoadResString(ResStringRec: PResStringRec): widestring;\r
+begin\r
+ Result:=DefaultInstance.LoadResString(ResStringRec);\r
+end;\r
+\r
+function LoadResStringW(ResStringRec: PResStringRec): widestring;\r
+begin\r
+ Result:=DefaultInstance.LoadResString(ResStringRec);\r
+end;\r
+\r
+\r
+\r
+function GetCurrentLanguage:string;\r
+begin\r
+ Result:=DefaultInstance.GetCurrentLanguage;\r
+end;\r
+\r
+{ TDomain }\r
+\r
+procedure TDomain.CloseMoFile;\r
+begin\r
+ if mofile<>nil then begin\r
+ FileLocator.ReleaseMoFile(mofile);\r
+ mofile:=nil;\r
+ end;\r
+ OpenHasFailedBefore:=False;\r
+end;\r
+\r
+destructor TDomain.Destroy;\r
+begin\r
+ CloseMoFile;\r
+ inherited;\r
+end;\r
+\r
+{$ifdef mswindows}\r
+function GetLastWinError:string;\r
+var\r
+ errcode:Cardinal;\r
+begin\r
+ SetLength (Result,2000);\r
+ errcode:=GetLastError();\r
+ Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);\r
+ Result:=StrPas(PChar(Result));\r
+end;\r
+{$endif}\r
+\r
+procedure TDomain.OpenMoFile;\r
+var\r
+ filename: string;\r
+begin\r
+ // Check if it is already open\r
+ if mofile<>nil then\r
+ exit;\r
+\r
+ // Check if it has been attempted to open the file before\r
+ if OpenHasFailedBefore then\r
+ exit;\r
+\r
+ if SpecificFilename<>'' then\r
+ filename:=SpecificFilename\r
+ else begin\r
+ filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r
+ if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then\r
+ filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r
+ end;\r
+ if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin\r
+ OpenHasFailedBefore:=True;\r
+ exit;\r
+ end;\r
+ mofile:=FileLocator.GetMoFile(filename, DebugLogger);\r
+\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ if mofile.isSwappedArchitecture then\r
+ DebugLogger ('.mo file is swapped (comes from another CPU architecture)');\r
+ {$endif}\r
+\r
+ // Check, that the contents of the file is utf-8\r
+ if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin\r
+ CloseMoFile;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');\r
+ {$endif}\r
+ {$ifdef MSWINDOWS}\r
+ MessageBox(0,PChar('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'),'Localization problem',MB_OK);\r
+ {$else}\r
+ writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');\r
+ {$endif}\r
+ Enabled:=False;\r
+ end;\r
+end;\r
+\r
+function TDomain.GetTranslationProperty(\r
+ Propertyname: string): WideString;\r
+var\r
+ sl:TStringList;\r
+ i:integer;\r
+ s:string;\r
+begin\r
+ Propertyname:=uppercase(Propertyname)+': ';\r
+ sl:=TStringList.Create;\r
+ try\r
+ sl.Text:=utf8encode(gettext(''));\r
+ for i:=0 to sl.Count-1 do begin\r
+ s:=sl.Strings[i];\r
+ if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin\r
+ Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ finally\r
+ FreeAndNil (sl);\r
+ end;\r
+ Result:='';\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TDomain.setDirectory(const dir: string);\r
+begin\r
+ vDirectory := IncludeTrailingPathDelimiter(dir);\r
+ SpecificFilename:='';\r
+ CloseMoFile;\r
+end;\r
+\r
+procedure AddDomainForResourceString (const domain:string);\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain);\r
+ {$endif}\r
+ ResourceStringDomainListCS.BeginWrite;\r
+ try\r
+ if ResourceStringDomainList.IndexOf(domain)=-1 then\r
+ ResourceStringDomainList.Add (domain);\r
+ finally\r
+ ResourceStringDomainListCS.EndWrite;\r
+ end;\r
+end;\r
+\r
+procedure RemoveDomainForResourceString (const domain:string);\r
+var\r
+ i:integer;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain);\r
+ {$endif}\r
+ ResourceStringDomainListCS.BeginWrite;\r
+ try\r
+ i:=ResourceStringDomainList.IndexOf(domain);\r
+ if i<>-1 then\r
+ ResourceStringDomainList.Delete (i);\r
+ finally\r
+ ResourceStringDomainListCS.EndWrite;\r
+ end;\r
+end;\r
+\r
+procedure TDomain.SetLanguageCode(const langcode: string);\r
+begin\r
+ CloseMoFile;\r
+ curlang:=langcode;\r
+end;\r
+\r
+function GetPluralForm2EN(Number: Integer): Integer;\r
+begin\r
+ Number:=abs(Number);\r
+ if Number=1 then Result:=0 else Result:=1;\r
+end;\r
+\r
+function GetPluralForm1(Number: Integer): Integer;\r
+begin\r
+ Result:=0;\r
+end;\r
+\r
+function GetPluralForm2FR(Number: Integer): Integer;\r
+begin\r
+ Number:=abs(Number);\r
+ if (Number=1) or (Number=0) then Result:=0 else Result:=1;\r
+end;\r
+\r
+function GetPluralForm3LV(Number: Integer): Integer;\r
+begin\r
+ Number:=abs(Number);\r
+ if (Number mod 10=1) and (Number mod 100<>11) then\r
+ Result:=0\r
+ else\r
+ if Number<>0 then Result:=1\r
+ else Result:=2;\r
+end;\r
+\r
+function GetPluralForm3GA(Number: Integer): Integer;\r
+begin\r
+ Number:=abs(Number);\r
+ if Number=1 then Result:=0\r
+ else if Number=2 then Result:=1\r
+ else Result:=2;\r
+end;\r
+\r
+function GetPluralForm3LT(Number: Integer): Integer;\r
+var\r
+ n1,n2:byte;\r
+begin\r
+ Number:=abs(Number);\r
+ n1:=Number mod 10;\r
+ n2:=Number mod 100;\r
+ if (n1=1) and (n2<>11) then\r
+ Result:=0\r
+ else\r
+ if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1\r
+ else Result:=2;\r
+end;\r
+\r
+function GetPluralForm3PL(Number: Integer): Integer;\r
+var\r
+ n1,n2:byte;\r
+begin\r
+ Number:=abs(Number);\r
+ n1:=Number mod 10;\r
+ n2:=Number mod 100;\r
+ if n1=1 then Result:=0\r
+ else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1\r
+ else Result:=2;\r
+end;\r
+\r
+function GetPluralForm3RU(Number: Integer): Integer;\r
+var\r
+ n1,n2:byte;\r
+begin\r
+ Number:=abs(Number);\r
+ n1:=Number mod 10;\r
+ n2:=Number mod 100;\r
+ if (n1=1) and (n2<>11) then\r
+ Result:=0\r
+ else\r
+ if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1\r
+ else Result:=2;\r
+end;\r
+\r
+function GetPluralForm4SL(Number: Integer): Integer;\r
+var\r
+ n2:byte;\r
+begin\r
+ Number:=abs(Number);\r
+ n2:=Number mod 100;\r
+ if n2=1 then Result:=0\r
+ else\r
+ if n2=2 then Result:=1\r
+ else\r
+ if (n2=3) or (n2=4) then Result:=2\r
+ else\r
+ Result:=3;\r
+end;\r
+\r
+procedure TDomain.GetListOfLanguages(list: TStrings);\r
+var\r
+ sr:TSearchRec;\r
+ more:boolean;\r
+ filename, path, langcode:string;\r
+ i, j:integer;\r
+begin\r
+ list.Clear;\r
+\r
+ // Iterate through filesystem\r
+ more:=FindFirst (Directory+'*',faAnyFile,sr)=0;\r
+ while more do begin\r
+ if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin\r
+ filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r
+ if fileexists(filename) then begin\r
+ langcode:=lowercase(sr.name);\r
+ if list.IndexOf(langcode)=-1 then\r
+ list.Add(langcode);\r
+ end;\r
+ end;\r
+ more:=FindNext (sr)=0;\r
+ end;\r
+\r
+ // Iterate through embedded files\r
+ for i:=0 to FileLocator.filelist.Count-1 do begin\r
+ filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];\r
+ path:=Directory;\r
+ {$ifdef MSWINDOWS}\r
+ path:=uppercase(path);\r
+ filename:=uppercase(filename);\r
+ {$endif}\r
+ j:=length(path);\r
+ if copy(filename,1,j)=path then begin\r
+ path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r
+ {$ifdef MSWINDOWS}\r
+ path:=uppercase(path);\r
+ {$endif}\r
+ if copy(filename,length(filename)-length(path)+1,length(path))=path then begin\r
+ langcode:=lowercase(copy(filename,j+1,length(filename)-length(path)-j));\r
+ if list.IndexOf(langcode)=-1 then\r
+ list.Add(langcode);\r
+ end;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure TDomain.SetFilename(const filename: string);\r
+begin\r
+ CloseMoFile;\r
+ vDirectory := '';\r
+ SpecificFilename:=filename;\r
+end;\r
+\r
+function TDomain.gettext(const msgid: ansistring): ansistring;\r
+var\r
+ found:boolean;\r
+begin\r
+ if not Enabled then begin\r
+ Result:=msgid;\r
+ exit;\r
+ end;\r
+ if (mofile=nil) and (not OpenHasFailedBefore) then\r
+ OpenMoFile;\r
+ if mofile=nil then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger('.mo file is not open. Not translating "'+msgid+'"');\r
+ {$endif}\r
+ Result := msgid;\r
+ end else begin\r
+ Result:=mofile.gettext(msgid,found);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ if found then\r
+ DebugLogger ('Found in .mo ('+Domain+'): "'+utf8encode(msgid)+'"->"'+utf8encode(Result)+'"')\r
+ else\r
+ DebugLogger ('Translation not found in .mo file ('+Domain+') : "'+utf8encode(msgid)+'"');\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+constructor TDomain.Create;\r
+begin\r
+ inherited Create;\r
+ Enabled:=True;\r
+end;\r
+\r
+{ TGnuGettextInstance }\r
+\r
+procedure TGnuGettextInstance.bindtextdomain(const szDomain,\r
+ szDirectory: string);\r
+var\r
+ dir:string;\r
+begin\r
+ dir:=IncludeTrailingPathDelimiter(szDirectory);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Text domain "'+szDomain+'" is now located at "'+dir+'"');\r
+ {$endif}\r
+ getdomain(szDomain,DefaultDomainDirectory,CurLang).Directory := dir;\r
+ WhenNewDomainDirectory (szDomain, szDirectory);\r
+end;\r
+\r
+constructor TGnuGettextInstance.Create;\r
+begin\r
+ CreatorThread:=GetCurrentThreadId;\r
+ {$ifdef MSWindows}\r
+ DesignTimeCodePage:=CP_ACP;\r
+ {$endif}\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r
+ DebugLog:=TMemoryStream.Create;\r
+ DebugWriteln('Debug log started '+DateTimeToStr(Now));\r
+ DebugWriteln('');\r
+ {$endif}\r
+ curGetPluralForm:=GetPluralForm2EN;\r
+ Enabled:=True;\r
+ curmsgdomain:=DefaultTextDomain;\r
+ savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;\r
+ domainlist := TStringList.Create;\r
+ TP_IgnoreList:=TStringList.Create;\r
+ TP_IgnoreList.Sorted:=True;\r
+ TP_GlobalClassHandling:=TList.Create;\r
+ TP_ClassHandling:=TList.Create;\r
+\r
+ // Set some settings\r
+ DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';\r
+\r
+ UseLanguage('');\r
+\r
+ bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);\r
+ textdomain(DefaultTextDomain);\r
+\r
+ // Add default properties to ignore\r
+ TP_GlobalIgnoreClassProperty(TComponent,'Name');\r
+ TP_GlobalIgnoreClassProperty(TCollection,'PropName');\r
+end;\r
+\r
+destructor TGnuGettextInstance.Destroy;\r
+begin\r
+ if savememory <> nil then begin\r
+ savefileCS.BeginWrite;\r
+ try\r
+ CloseFile(savefile);\r
+ finally\r
+ savefileCS.EndWrite;\r
+ end;\r
+ FreeAndNil(savememory);\r
+ end;\r
+ FreeAndNil (savefileCS);\r
+ FreeAndNil (TP_IgnoreList);\r
+ while TP_GlobalClassHandling.Count<>0 do begin\r
+ TObject(TP_GlobalClassHandling.Items[0]).Free;\r
+ TP_GlobalClassHandling.Delete(0);\r
+ end;\r
+ FreeAndNil (TP_GlobalClassHandling);\r
+ FreeTP_ClassHandlingItems;\r
+ FreeAndNil (TP_ClassHandling);\r
+ while domainlist.Count <> 0 do begin\r
+ domainlist.Objects[0].Free;\r
+ domainlist.Delete(0);\r
+ end;\r
+ FreeAndNil(domainlist);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ FreeAndNil (DebugLog);\r
+ FreeAndNil (DebugLogCS);\r
+ {$endif}\r
+ inherited;\r
+end;\r
+\r
+{$ifndef DELPHI5OROLDER}\r
+function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: ansistring): widestring;\r
+begin\r
+ Result:=dgettext(szDomain, ansi2wide(szMsgId));\r
+end;\r
+{$endif}\r
+\r
+function TGnuGettextInstance.dgettext(const szDomain: string;\r
+ const szMsgId: widestring): widestring;\r
+begin\r
+ if not Enabled then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Translation has been disabled. Text is not being translated: '+szMsgid);\r
+ {$endif}\r
+ Result:=szMsgId;\r
+ end else begin\r
+ Result:=UTF8Decode(LF2LineBreakA(getdomain(szDomain,DefaultDomainDirectory,CurLang).gettext(StripCR(utf8encode(szMsgId)))));\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ if (szMsgId<>'') and (Result='') then\r
+ DebugWriteln (Format('Error: Translation of %s was an empty string. This may never occur.',[szMsgId]));\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+function TGnuGettextInstance.GetCurrentLanguage: string;\r
+begin\r
+ Result:=curlang;\r
+end;\r
+\r
+function TGnuGettextInstance.getcurrenttextdomain: string;\r
+begin\r
+ Result := curmsgdomain;\r
+end;\r
+\r
+{$ifndef DELPHI5OROLDER}\r
+function TGnuGettextInstance.gettext(\r
+ const szMsgId: ansistring): widestring;\r
+begin\r
+ Result := dgettext(curmsgdomain, szMsgId);\r
+end;\r
+{$endif}\r
+\r
+function TGnuGettextInstance.gettext(\r
+ const szMsgId: widestring): widestring;\r
+begin\r
+ Result := dgettext(curmsgdomain, szMsgId);\r
+end;\r
+\r
+procedure TGnuGettextInstance.textdomain(const szDomain: string);\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Changed text domain to "'+szDomain+'"');\r
+ {$endif}\r
+ curmsgdomain := szDomain;\r
+ WhenNewDomain (szDomain);\r
+end;\r
+\r
+function TGnuGettextInstance.TP_CreateRetranslator : TExecutable;\r
+var\r
+ ttpr:TTP_Retranslator;\r
+begin\r
+ ttpr:=TTP_Retranslator.Create;\r
+ ttpr.Instance:=self;\r
+ TP_Retranslator:=ttpr;\r
+ Result:=ttpr;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('A retranslator was created.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;\r
+ Handler: TTranslator);\r
+var\r
+ cm:TClassMode;\r
+ i:integer;\r
+begin\r
+ for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r
+ if cm.HClass=HClass then\r
+ raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.');\r
+ if HClass.InheritsFrom(cm.HClass) then begin\r
+ // This is the place to insert this class\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=HClass;\r
+ cm.SpecialHandler:=Handler;\r
+ TP_GlobalClassHandling.Insert(i,cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=HClass;\r
+ cm.SpecialHandler:=Handler;\r
+ TP_GlobalClassHandling.Add(cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);\r
+var\r
+ cm:TClassMode;\r
+ i:integer;\r
+begin\r
+ for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r
+ if cm.HClass=IgnClass then\r
+ raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'. You should keep all TP_Global functions in one place in your source code.');\r
+ if IgnClass.InheritsFrom(cm.HClass) then begin\r
+ // This is the place to insert this class\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ TP_GlobalClassHandling.Insert(i,cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ TP_GlobalClassHandling.Add(cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(\r
+ IgnClass: TClass; propertyname: string);\r
+var\r
+ cm:TClassMode;\r
+ i,idx:integer;\r
+begin\r
+ propertyname:=uppercase(propertyname);\r
+ for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r
+ if cm.HClass=IgnClass then begin\r
+ if Assigned(cm.SpecialHandler) then\r
+ raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');\r
+ if not cm.PropertiesToIgnore.Find(propertyname,idx) then\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ if IgnClass.InheritsFrom(cm.HClass) then begin\r
+ // This is the place to insert this class\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ TP_GlobalClassHandling.Insert(i,cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ TP_GlobalClassHandling.Add(cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;\r
+ const name: string);\r
+begin\r
+ TP_IgnoreList.Add(uppercase(name));\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name);\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;\r
+ const TextDomain: string);\r
+var\r
+ comp:TGnuGettextComponentMarker;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('======================================================================');\r
+ DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.');\r
+ {$endif}\r
+ comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;\r
+ if comp=nil then begin\r
+ comp:=TGnuGettextComponentMarker.Create (nil);\r
+ comp.Name:='GNUgettextMarker';\r
+ comp.Retranslator:=TP_CreateRetranslator;\r
+ TranslateProperties (AnObject, TextDomain);\r
+ AnObject.InsertComponent(comp);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.');\r
+ {$endif}\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('This is not the first time, that this component has been translated.');\r
+ {$endif}\r
+ if comp.LastLanguage<>curlang then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.');\r
+ {$endif}\r
+ {$ifdef mswindows}\r
+ MessageBox (0,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.','Error',MB_OK);\r
+ {$else}\r
+ writeln (stderr,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.');\r
+ {$endif}\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.');\r
+ {$endif}\r
+ end;\r
+ end;\r
+ comp.LastLanguage:=curlang;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('======================================================================');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:string);\r
+var\r
+ {$ifdef DELPHI5OROLDER}\r
+ ws: string;\r
+ old: string;\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ ppi:PPropInfo;\r
+ ws: WideString;\r
+ old: WideString;\r
+ {$endif}\r
+ obj:TObject;\r
+ Propname:string;\r
+begin\r
+ PropName:=PropInfo^.Name;\r
+ try\r
+ // Translate certain types of properties\r
+ case PropInfo^.PropType^.Kind of\r
+ tkString, tkLString, tkWString:\r
+ begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName);\r
+ {$endif}\r
+ {$ifdef DELPHI5OROLDER}\r
+ old := GetStrProp(AnObject, PropName);\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ if PropInfo^.PropType^.Kind<>tkWString then\r
+ old := ansi2wide(GetStrProp(AnObject, PropName))\r
+ else\r
+ old := GetWideStrProp(AnObject, PropName);\r
+ {$endif}\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ if old='' then\r
+ DebugWriteln ('(Empty, not translated)')\r
+ else\r
+ DebugWriteln ('Old value: "'+old+'"');\r
+ {$endif}\r
+ if (old <> '') and (IsWriteProp(PropInfo)) then begin\r
+ if TP_Retranslator<>nil then\r
+ (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);\r
+ ws := dgettext(textdomain,old);\r
+ if ws <> old then begin\r
+ {$ifdef DELPHI5OROLDER}\r
+ SetStrProp(AnObject, PropName, ws);\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ ppi:=GetPropInfo(AnObject, Propname);\r
+ if ppi<>nil then begin\r
+ SetWideStrProp(AnObject, ppi, ws);\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('ERROR: Property disappeared: '+Propname+' for object of type '+AnObject.ClassName);\r
+ {$endif}\r
+ end;\r
+ {$endif}\r
+ end;\r
+ end;\r
+ end { case item };\r
+ tkClass:\r
+ begin\r
+// obj:=GetObjectProp(AnObject, PropName);\r
+// if obj<>nil then\r
+// TodoList.AddObject ('',obj);\r
+ end { case item };\r
+ end { case };\r
+ except\r
+ on E:Exception do\r
+ raise EGGComponentError.Create ('Property cannot be translated.'+sLineBreak+\r
+ 'Add TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','''+PropName+''') to your source code or use'+sLineBreak+\r
+ 'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+\r
+ 'Reason: '+e.Message);\r
+ end;\r
+end;\r
+\r
+procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:string='');\r
+var\r
+ TodoList:TStringList; // List of Name/TObject's that is to be processed\r
+ DoneList:TStringList; // List of hex codes representing pointers to objects that have been done\r
+ i, j, Count: integer;\r
+ PropList: PPropList;\r
+ UPropName: string;\r
+ PropInfo: PPropInfo;\r
+ comp:TComponent;\r
+ cm,currentcm:TClassMode;\r
+ ObjectPropertyIgnoreList:TStringList;\r
+ objid, Name:string;\r
+ {$ifdef DELPHI5OROLDER}\r
+ Data:PTypeData;\r
+ {$endif}\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('----------------------------------------------------------------------');\r
+ DebugWriteln ('TranslateProperties() was called for an object of class '+AnObject.ClassName+' with domain "'+textdomain+'".');\r
+ {$endif}\r
+ if textdomain='' then\r
+ textdomain:=curmsgdomain;\r
+ if TP_Retranslator<>nil then\r
+ (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;\r
+ DoneList:=TStringList.Create;\r
+ TodoList:=TStringList.Create;\r
+ ObjectPropertyIgnoreList:=TStringList.Create;\r
+ try\r
+ TodoList.AddObject('', AnObject);\r
+ DoneList.Sorted:=True;\r
+ ObjectPropertyIgnoreList.Sorted:=True;\r
+ {$ifndef DELPHI5OROLDER}\r
+ ObjectPropertyIgnoreList.Duplicates:=dupIgnore;\r
+ ObjectPropertyIgnoreList.CaseSensitive:=False;\r
+ DoneList.Duplicates:=dupError;\r
+ DoneList.CaseSensitive:=True;\r
+ {$endif}\r
+\r
+ while TodoList.Count<>0 do begin\r
+ AnObject:=TodoList.Objects[0];\r
+ Name:=TodoList.Strings[0];\r
+ TodoList.Delete(0);\r
+ if (AnObject<>nil) and (AnObject is TPersistent) then begin\r
+ // Make sure each object is only translated once\r
+ Assert (sizeof(integer)=sizeof(TObject));\r
+ objid:=IntToHex(integer(AnObject),8);\r
+ if DoneList.Find(objid,i) then begin\r
+ continue;\r
+ end else begin\r
+ DoneList.Add(objid);\r
+ end;\r
+\r
+ ObjectPropertyIgnoreList.Clear;\r
+\r
+ // Find out if there is special handling of this object\r
+ currentcm:=nil;\r
+ // First check the local handling instructions\r
+ for j:=0 to TP_ClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode;\r
+ if AnObject.InheritsFrom(cm.HClass) then begin\r
+ if cm.PropertiesToIgnore.Count<>0 then begin\r
+ ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);\r
+ end else begin\r
+ // Ignore the entire class\r
+ currentcm:=cm;\r
+ break;\r
+ end;\r
+ end;\r
+ end;\r
+ // Then check the global handling instructions\r
+ if currentcm=nil then\r
+ for j:=0 to TP_GlobalClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_GlobalClassHandling.Items[j]) as TClassMode;\r
+ if AnObject.InheritsFrom(cm.HClass) then begin\r
+ if cm.PropertiesToIgnore.Count<>0 then begin\r
+ ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);\r
+ end else begin\r
+ // Ignore the entire class\r
+ currentcm:=cm;\r
+ break;\r
+ end;\r
+ end;\r
+ end;\r
+ if currentcm<>nil then begin\r
+ ObjectPropertyIgnoreList.Clear;\r
+ // Ignore or use special handler\r
+ if Assigned(currentcm.SpecialHandler) then begin\r
+ currentcm.SpecialHandler (AnObject);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Special handler activated for '+AnObject.ClassName);\r
+ {$endif}\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Ignoring object '+AnObject.ClassName);\r
+ {$endif}\r
+ end;\r
+ continue;\r
+ end;\r
+\r
+ {$ifdef DELPHI5OROLDER}\r
+ if AnObject.ClassInfo=nil then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('ClassInfo=nil encountered for class '+AnObject.ClassName+'. Translation of that component has stopped. You should ignore this object.');\r
+ {$endif}\r
+ continue;\r
+ end;\r
+ Data := GetTypeData(AnObject.Classinfo);\r
+ Count := Data^.PropCount;\r
+ GetMem(PropList, Count * Sizeof(PPropInfo));\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ Count := GetPropList(AnObject, PropList);\r
+ {$endif}\r
+ try\r
+ {$ifdef DELPHI5OROLDER}\r
+ GetPropInfos(AnObject.ClassInfo, PropList);\r
+ {$endif}\r
+ for j := 0 to Count - 1 do begin\r
+ PropInfo := PropList[j];\r
+ UPropName:=uppercase(PropInfo^.Name);\r
+ // Ignore properties that are meant to be ignored\r
+ if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and\r
+ (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and\r
+ (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin\r
+ TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);\r
+ end; // if\r
+ end; // for\r
+ finally\r
+ {$ifdef DELPHI5OROLDER}\r
+ FreeMem(PropList, Data^.PropCount * Sizeof(PPropInfo));\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ if Count<>0 then\r
+ FreeMem (PropList);\r
+ {$endif}\r
+ end;\r
+ if AnObject is TStrings then begin\r
+ if ((AnObject as TStrings).Text<>'') and (TP_Retranslator<>nil) then\r
+ (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text);\r
+ TranslateStrings (AnObject as TStrings,TextDomain);\r
+ end;\r
+ // Check for TCollection\r
+ if AnObject is TCollection then begin\r
+ for i := 0 to (AnObject as TCollection).Count - 1 do\r
+ TodoList.AddObject('',(AnObject as TCollection).Items[i]);\r
+ end;\r
+ if AnObject is TComponent then begin\r
+ for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin\r
+ comp:=TComponent(AnObject).Components[i];\r
+ if (not TP_IgnoreList.Find(uppercase(comp.Name),j)) then begin\r
+ TodoList.AddObject(uppercase(comp.Name),comp);\r
+ end;\r
+ end;\r
+ end;\r
+ end { if AnObject<>nil };\r
+ end { while todolist.count<>0 };\r
+ finally\r
+ FreeAndNil (todolist);\r
+ FreeAndNil (ObjectPropertyIgnoreList);\r
+ FreeAndNil (DoneList);\r
+ end;\r
+ FreeTP_ClassHandlingItems;\r
+ TP_IgnoreList.Clear;\r
+ TP_Retranslator:=nil;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('----------------------------------------------------------------------');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);\r
+var\r
+ i,p:integer;\r
+ dom:TDomain;\r
+ l2:string[2];\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln('UseLanguage('''+LanguageCode+'''); called');\r
+ {$endif}\r
+\r
+ if LanguageCode='' then begin\r
+ LanguageCode:=GGGetEnvironmentVariable('LANG');\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('LANG env variable is '''+LanguageCode+'''.');\r
+ {$endif}\r
+ {$ifdef MSWINDOWS}\r
+ if LanguageCode='' then begin\r
+ LanguageCode:=GetWindowsLanguage;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.');\r
+ {$endif}\r
+ end;\r
+ {$endif}\r
+ p:=pos('.',LanguageCode);\r
+ if p<>0 then\r
+ LanguageCode:=copy(LanguageCode,1,p-1);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Language code that will be set is '''+LanguageCode+'''.');\r
+ {$endif}\r
+ end;\r
+\r
+ curlang := LanguageCode;\r
+ for i:=0 to domainlist.Count-1 do begin\r
+ dom:=domainlist.Objects[i] as TDomain;\r
+ dom.SetLanguageCode (curlang);\r
+ end;\r
+\r
+ l2:=lowercase(copy(curlang,1,2));\r
+ if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else\r
+ if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else\r
+ if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else\r
+ if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else\r
+ if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else\r
+ if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else\r
+ if (l2='ru') or (l2='cs') or (l2='sk') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else\r
+ if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else\r
+ if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else begin\r
+ curGetPluralForm:=GetPluralForm2EN;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Plural form for the language was not found. English plurality system assumed.');\r
+ {$endif}\r
+ end;\r
+\r
+ WhenNewLanguage (curlang);\r
+\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln('');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;const TextDomain:string);\r
+var\r
+ line: string;\r
+ i: integer;\r
+ s:TStringList;\r
+begin\r
+ if sl.Count > 0 then begin\r
+ sl.BeginUpdate;\r
+ try\r
+ s:=TStringList.Create;\r
+ try\r
+ s.Assign (sl);\r
+ for i:=0 to s.Count-1 do begin\r
+ line:=s.Strings[i];\r
+ if line<>'' then\r
+ s.Strings[i]:=dgettext(TextDomain,line);\r
+ end;\r
+ sl.Assign(s);\r
+ finally\r
+ FreeAndNil (s);\r
+ end;\r
+ finally\r
+ sl.EndUpdate;\r
+ end;\r
+ end;\r
+end;\r
+\r
+function TGnuGettextInstance.GetTranslatorNameAndEmail: widestring;\r
+begin\r
+ Result:=GetTranslationProperty('LAST-TRANSLATOR');\r
+end;\r
+\r
+function TGnuGettextInstance.GetTranslationProperty(\r
+ const Propertyname: string): WideString;\r
+begin\r
+ Result:=getdomain(curmsgdomain,DefaultDomainDirectory,CurLang).GetTranslationProperty (Propertyname);\r
+end;\r
+\r
+function TGnuGettextInstance.dngettext(const szDomain: string; const singular, plural: widestring;\r
+ Number: Integer): widestring;\r
+var\r
+ org,trans:widestring;\r
+ idx:integer;\r
+ p:integer;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('dngettext translation (domain '+szDomain+', number is '+IntTostr(Number)+') of '+singular+'/'+plural);\r
+ {$endif}\r
+ org:=singular+#0+plural;\r
+ trans:=dgettext(szDomain,org);\r
+ if org=trans then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Translation was equal to english version. English plural forms assumed.');\r
+ {$endif}\r
+ idx:=GetPluralForm2EN(Number)\r
+ end else\r
+ idx:=curGetPluralForm(Number);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Index '+IntToStr(idx)+' will be used');\r
+ {$endif}\r
+ while true do begin\r
+ p:=pos(#0,trans);\r
+ if p=0 then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Last translation used: '+utf8encode(trans));\r
+ {$endif}\r
+ Result:=trans;\r
+ exit;\r
+ end;\r
+ if idx=0 then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Translation found: '+utf8encode(trans));\r
+ {$endif}\r
+ Result:=copy(trans,1,p-1);\r
+ exit;\r
+ end;\r
+ delete (trans,1,p);\r
+ dec (idx);\r
+ end;\r
+end;\r
+\r
+{$ifndef DELPHI5OROLDER}\r
+function TGnuGettextInstance.ngettext(const singular, plural: ansistring;\r
+ Number: Integer): widestring;\r
+begin\r
+ Result := dngettext(curmsgdomain, singular, plural, Number);\r
+end;\r
+{$endif}\r
+\r
+function TGnuGettextInstance.ngettext(const singular, plural: widestring;\r
+ Number: Integer): widestring;\r
+begin\r
+ Result := dngettext(curmsgdomain, singular, plural, Number);\r
+end;\r
+\r
+procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: string);\r
+begin\r
+ // This is meant to be empty.\r
+end;\r
+\r
+procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: string);\r
+begin\r
+ // This is meant to be empty.\r
+end;\r
+\r
+procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain,\r
+ Directory: string);\r
+begin\r
+ // This is meant to be empty.\r
+end;\r
+\r
+procedure TGnuGettextInstance.GetListOfLanguages(const domain: string;\r
+ list: TStrings);\r
+begin\r
+ getdomain(Domain,DefaultDomainDirectory,CurLang).GetListOfLanguages(list);\r
+end;\r
+\r
+procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain,\r
+ filename: string);\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Text domain "'+szDomain+'" is now bound to file named "'+filename+'"');\r
+ {$endif}\r
+ getdomain(szDomain,DefaultDomainDirectory,CurLang).SetFilename (filename);\r
+end;\r
+\r
+procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean);\r
+begin\r
+ DebugLogOutputPaused:=PauseEnabled;\r
+end;\r
+\r
+procedure TGnuGettextInstance.DebugLogToFile(const filename: string; append:boolean=false);\r
+{$ifdef DXGETTEXTDEBUG}\r
+var\r
+ fs:TFileStream;\r
+ marker:string;\r
+{$endif}\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ // Create the file if needed\r
+ if (not fileexists(filename)) or (not append) then\r
+ fileclose (filecreate (filename));\r
+\r
+ // Open file\r
+ fs:=TFileStream.Create (filename,fmOpenWrite or fmShareDenyWrite);\r
+ if append then\r
+ fs.Seek(0,soFromEnd);\r
+\r
+ // Write header if appending\r
+ if fs.Position<>0 then begin\r
+ marker:=sLineBreak+'==========================================================================='+sLineBreak;\r
+ fs.WriteBuffer(marker[1],length(marker));\r
+ end;\r
+\r
+ // Copy the memorystream contents to the file\r
+ DebugLog.Seek(0,soFromBeginning);\r
+ fs.CopyFrom(DebugLog,0);\r
+\r
+ // Make DebugLog point to the filestream\r
+ FreeAndNil (DebugLog);\r
+ DebugLog:=fs;\r
+{$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.DebugWriteln(line: ansistring);\r
+Var\r
+ Discard: Boolean;\r
+begin\r
+ Assert (DebugLogCS<>nil);\r
+ Assert (DebugLog<>nil);\r
+\r
+ DebugLogCS.BeginWrite;\r
+ try\r
+ if DebugLogOutputPaused then\r
+ exit;\r
+\r
+ if Assigned (fOnDebugLine) then begin\r
+ Discard := True;\r
+ fOnDebugLine (Self, Line, Discard);\r
+ If Discard then Exit;\r
+ end;\r
+\r
+ line:=line+sLineBreak;\r
+\r
+ // Ensure that memory usage doesn't get too big.\r
+ if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin\r
+ line:=sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak+\r
+ 'Debug log halted because memory usage grew too much.'+sLineBreak+\r
+ 'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.'+\r
+ sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak;\r
+ DebugLogOutputPaused:=True;\r
+ end;\r
+ DebugLog.WriteBuffer(line[1],length(line));\r
+ finally\r
+ DebugLogCS.EndWrite;\r
+ end;\r
+end;\r
+\r
+function TGnuGettextInstance.Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;\r
+// Retrieves the TDomain object for the specified domain.\r
+// Creates one, if none there, yet.\r
+var\r
+ idx: integer;\r
+begin\r
+ idx := domainlist.IndexOf(Domain);\r
+ if idx = -1 then begin\r
+ Result := TDomain.Create;\r
+ Result.DebugLogger:=DebugWriteln;\r
+ Result.Domain := Domain;\r
+ Result.Directory := DefaultDomainDirectory;\r
+ Result.SetLanguageCode(curlang);\r
+ domainlist.AddObject(Domain, Result);\r
+ end else begin\r
+ Result := domainlist.Objects[idx] as TDomain;\r
+ end;\r
+end;\r
+\r
+function TGnuGettextInstance.LoadResString(\r
+ ResStringRec: PResStringRec): widestring;\r
+{$ifdef MSWINDOWS}\r
+var\r
+ Len: Integer;\r
+ Buffer: array [0..1023] of char;\r
+{$endif}\r
+{$ifdef LINUX }\r
+const\r
+ ResStringTableLen = 16;\r
+type\r
+ ResStringTable = array [0..ResStringTableLen-1] of LongWord;\r
+var\r
+ Handle: TResourceHandle;\r
+ Tab: ^ResStringTable;\r
+ ResMod: HMODULE;\r
+{$endif }\r
+begin\r
+ if ResStringRec=nil then\r
+ exit;\r
+ if ResStringRec.Identifier>=64*1024 then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier');\r
+ {$endif}\r
+ Result:='ERROR';\r
+ exit;\r
+ end else begin\r
+ {$ifdef LINUX}\r
+ // This works with Unicode if the Linux has utf-8 character set\r
+ // Result:=System.LoadResString(ResStringRec);\r
+ ResMod:=FindResourceHInstance(ResStringRec^.Module^);\r
+ Handle:=FindResource(ResMod,\r
+ PChar(ResStringRec^.Identifier div ResStringTableLen), PChar(6)); // RT_STRING\r
+ Tab:=Pointer(LoadResource(ResMod, Handle));\r
+ if Tab=nil then\r
+ Result:=''\r
+ else\r
+ Result:=PWideChar(PChar(Tab)+Tab[ResStringRec^.Identifier mod ResStringTableLen]);\r
+ {$endif}\r
+ {$ifdef MSWINDOWS}\r
+ if not Win32PlatformIsUnicode then begin\r
+ SetString(Result, Buffer,\r
+ LoadString(FindResourceHInstance(ResStringRec.Module^),\r
+ ResStringRec.Identifier, Buffer, SizeOf(Buffer)))\r
+ end else begin\r
+ Result := '';\r
+ Len := 0;\r
+ While Len = Length(Result) do begin\r
+ if Length(Result) = 0 then\r
+ SetLength(Result, 1024)\r
+ else\r
+ SetLength(Result, Length(Result) * 2);\r
+ Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),\r
+ ResStringRec.Identifier, PWideChar(Result), Length(Result));\r
+ end;\r
+ SetLength(Result, Len);\r
+ end;\r
+ {$endif}\r
+ end;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Loaded resourcestring: '+utf8encode(Result));\r
+ {$endif}\r
+ if CreatorThread<>GetCurrentThreadId then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('LoadResString was called from an invalid thread. Resourcestring was not translated.');\r
+ {$endif}\r
+ end else\r
+ Result:=ResourceStringGettext(Result);\r
+end;\r
+\r
+procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent;\r
+ const TextDomain: string);\r
+var\r
+ comp:TGnuGettextComponentMarker;\r
+begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('======================================================================');\r
+ DebugWriteln ('RetranslateComponent() was called for a component with name '+AnObject.Name+'.');\r
+ {$endif}\r
+ comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;\r
+ if comp=nil then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Retranslate was called on an object that has not been translated before. An Exception is being raised.');\r
+ {$endif}\r
+ raise EGGProgrammingError.Create ('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().');\r
+ end else begin\r
+ if comp.LastLanguage<>curlang then begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('The retranslator is being executed.');\r
+ {$endif}\r
+ comp.Retranslator.Execute;\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('The language has not changed. The retranslator is not executed.');\r
+ {$endif}\r
+ end;\r
+ end;\r
+ comp.LastLanguage:=curlang;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('======================================================================');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass);\r
+var\r
+ cm:TClassMode;\r
+ i:integer;\r
+begin\r
+ for i:=0 to TP_ClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;\r
+ if cm.HClass=IgnClass then\r
+ raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'.');\r
+ if IgnClass.InheritsFrom(cm.HClass) then begin\r
+ // This is the place to insert this class\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ TP_ClassHandling.Insert(i,cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ TP_ClassHandling.Add(cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass;\r
+ propertyname: string);\r
+var\r
+ cm:TClassMode;\r
+ i:integer;\r
+begin\r
+ propertyname:=uppercase(propertyname);\r
+ for i:=0 to TP_ClassHandling.Count-1 do begin\r
+ cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;\r
+ if cm.HClass=IgnClass then begin\r
+ if Assigned(cm.SpecialHandler) then\r
+ raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ if IgnClass.InheritsFrom(cm.HClass) then begin\r
+ // This is the place to insert this class\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ TP_ClassHandling.Insert(i,cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+ exit;\r
+ end;\r
+ end;\r
+ cm:=TClassMode.Create;\r
+ cm.HClass:=IgnClass;\r
+ cm.PropertiesToIgnore.Add(propertyname);\r
+ TP_GlobalClassHandling.Add(cm);\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r
+ {$endif}\r
+end;\r
+\r
+procedure TGnuGettextInstance.FreeTP_ClassHandlingItems;\r
+begin\r
+ while TP_ClassHandling.Count<>0 do begin\r
+ TObject(TP_ClassHandling.Items[0]).Free;\r
+ TP_ClassHandling.Delete(0);\r
+ end;\r
+end;\r
+\r
+function TGnuGettextInstance.ansi2wide(const s: ansistring): widestring;\r
+{$ifdef MSWindows}\r
+var\r
+ len:integer;\r
+{$endif}\r
+begin\r
+{$ifdef MSWindows}\r
+ if DesignTimeCodePage=CP_ACP then begin\r
+ // No design-time codepage specified. Using runtime codepage instead.\r
+{$endif}\r
+ Result:=s;\r
+{$ifdef MSWindows}\r
+ end else begin\r
+ len:=length(s);\r
+ if len=0 then\r
+ Result:=''\r
+ else begin\r
+ SetLength (Result,len);\r
+ len:=MultiByteToWideChar(DesignTimeCodePage,0,pchar(s),len,pwidechar(Result),len);\r
+ if len=0 then\r
+ raise EGGAnsi2WideConvError.Create ('Cannot convert string to widestring:'+sLineBreak+s);\r
+ SetLength (Result,len);\r
+ end;\r
+ end;\r
+{$endif}\r
+end;\r
+\r
+{$ifndef DELPHI5OROLDER}\r
+function TGnuGettextInstance.dngettext(const szDomain: string; const singular,\r
+ plural: ansistring; Number: Integer): widestring;\r
+begin\r
+ Result:=dngettext (szDomain, ansi2wide(singular), ansi2wide(plural), Number);\r
+end;\r
+{$endif}\r
+\r
+{ TClassMode }\r
+\r
+constructor TClassMode.Create;\r
+begin\r
+ PropertiesToIgnore:=TStringList.Create;\r
+ PropertiesToIgnore.Sorted:=True;\r
+ PropertiesToIgnore.Duplicates:=dupError;\r
+ {$ifndef DELPHI5OROLDER}\r
+ PropertiesToIgnore.CaseSensitive:=False;\r
+ {$endif}\r
+end;\r
+\r
+destructor TClassMode.Destroy;\r
+begin\r
+ FreeAndNil (PropertiesToIgnore);\r
+ inherited;\r
+end;\r
+\r
+{ TFileLocator }\r
+\r
+procedure TFileLocator.Analyze;\r
+var\r
+ s:ansistring;\r
+ i:integer;\r
+ offset:int64;\r
+ fs:TFileStream;\r
+ fi:TEmbeddedFileInfo;\r
+ filename:string;\r
+begin\r
+ s:='6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;\r
+ s:=copy(s,length(s)-7,8);\r
+ offset:=0;\r
+ for i:=8 downto 1 do\r
+ offset:=offset shl 8+ord(s[i]); \r
+ if offset=0 then\r
+ exit;\r
+ BaseDirectory:=ExtractFilePath(ExecutableFilename);\r
+ try\r
+ fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);\r
+ try\r
+ while true do begin\r
+ fs.Seek(offset,soFromBeginning);\r
+ offset:=ReadInt64(fs);\r
+ if offset=0 then\r
+ exit;\r
+ fi:=TEmbeddedFileInfo.Create;\r
+ try\r
+ fi.Offset:=ReadInt64(fs);\r
+ fi.Size:=ReadInt64(fs);\r
+ SetLength (filename, offset-fs.position);\r
+ fs.ReadBuffer (filename[1],offset-fs.position);\r
+ filename:=trim(filename);\r
+ filelist.AddObject(filename,fi);\r
+ except\r
+ FreeAndNil (fi);\r
+ raise;\r
+ end;\r
+ end;\r
+ finally\r
+ FreeAndNil (fs);\r
+ end;\r
+ except\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ raise;\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+constructor TFileLocator.Create;\r
+begin\r
+ MoFilesCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r
+ MoFiles:=TStringList.Create;\r
+ filelist:=TStringList.Create;\r
+ {$ifdef LINUX}\r
+ filelist.Duplicates:=dupError;\r
+ filelist.CaseSensitive:=True;\r
+ {$endif}\r
+ MoFiles.Sorted:=True;\r
+ {$ifndef DELPHI5OROLDER}\r
+ MoFiles.Duplicates:=dupError;\r
+ MoFiles.CaseSensitive:=False;\r
+ {$ifdef MSWINDOWS}\r
+ filelist.Duplicates:=dupError;\r
+ filelist.CaseSensitive:=False;\r
+ {$endif}\r
+ {$endif}\r
+ filelist.Sorted:=True;\r
+end;\r
+\r
+destructor TFileLocator.Destroy;\r
+begin\r
+ while filelist.count<>0 do begin\r
+ filelist.Objects[0].Free;\r
+ filelist.Delete (0);\r
+ end;\r
+ FreeAndNil (filelist);\r
+ FreeAndNil (MoFiles);\r
+ FreeAndNil (MoFilesCS);\r
+ inherited;\r
+end;\r
+\r
+function TFileLocator.FileExists(filename: string): boolean;\r
+var\r
+ idx:integer;\r
+begin\r
+ if copy(filename,1,length(basedirectory))=basedirectory then \r
+ filename:=copy(filename,length(basedirectory)+1,maxint);\r
+ Result:=filelist.Find(filename,idx);\r
+end;\r
+\r
+function TFileLocator.GetMoFile(filename: string; DebugLogger:TDebugLogger): TMoFile;\r
+var\r
+ fi:TEmbeddedFileInfo;\r
+ idx:integer;\r
+ idxname:string;\r
+ Offset, Size: Int64;\r
+ realfilename:string;\r
+begin\r
+ // Find real filename\r
+ offset:=0;\r
+ size:=0;\r
+ realfilename:=filename;\r
+ if copy(filename,1,length(basedirectory))=basedirectory then begin\r
+ filename:=copy(filename,length(basedirectory)+1,maxint);\r
+ idx:=filelist.IndexOf(filename);\r
+ if idx<>-1 then begin\r
+ fi:=filelist.Objects[idx] as TEmbeddedFileInfo;\r
+ realfilename:=ExecutableFilename;\r
+ offset:=fi.offset;\r
+ size:=fi.size;\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger ('Instead of '+filename+', using '+realfilename+' from offset '+IntTostr(offset)+', size '+IntToStr(size));\r
+ {$endif}\r
+ end;\r
+ end;\r
+\r
+\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ DebugLogger ('Reading .mo data from file '''+filename+'''');\r
+ {$endif}\r
+\r
+ // Find TMoFile object\r
+ MoFilesCS.BeginWrite;\r
+ try\r
+ idxname:=realfilename+#0+IntToStr(offset);\r
+ if MoFiles.Find(idxname, idx) then begin\r
+ Result:=MoFiles.Objects[idx] as TMoFile;\r
+ end else begin\r
+ Result:=TMoFile.Create (realfilename, Offset, Size);\r
+ MoFiles.AddObject(idxname, Result);\r
+ end;\r
+ Inc (Result.Users);\r
+ finally\r
+ MoFilesCS.EndWrite;\r
+ end;\r
+end;\r
+\r
+function TFileLocator.ReadInt64(str: TStream): int64;\r
+begin\r
+ Assert (sizeof(Result)=8);\r
+ str.ReadBuffer(Result,8);\r
+end;\r
+\r
+procedure TFileLocator.ReleaseMoFile(mofile: TMoFile);\r
+var\r
+ i:integer;\r
+begin\r
+ Assert (mofile<>nil);\r
+ \r
+ MoFilesCS.BeginWrite;\r
+ try\r
+ dec (mofile.Users);\r
+ if mofile.Users<=0 then begin\r
+ i:=MoFiles.Count-1;\r
+ while i>=0 do begin\r
+ if MoFiles.Objects[i]=mofile then begin\r
+ MoFiles.Delete(i);\r
+ FreeAndNil (mofile);\r
+ break;\r
+ end;\r
+ dec (i);\r
+ end;\r
+ end;\r
+ finally\r
+ MoFilesCS.EndWrite;\r
+ end;\r
+end;\r
+\r
+{ TTP_Retranslator }\r
+\r
+constructor TTP_Retranslator.Create;\r
+begin\r
+ list:=TList.Create;\r
+end;\r
+\r
+destructor TTP_Retranslator.Destroy;\r
+var\r
+ i:integer;\r
+begin\r
+ for i:=0 to list.Count-1 do\r
+ TObject(list.Items[i]).Free;\r
+ FreeAndNil (list);\r
+ inherited;\r
+end;\r
+\r
+procedure TTP_Retranslator.Execute;\r
+var\r
+ i:integer;\r
+ sl:TStrings;\r
+ item:TTP_RetranslatorItem;\r
+ newvalue:WideString;\r
+ {$ifndef DELPHI5OROLDER}\r
+ ppi:PPropInfo;\r
+ {$endif}\r
+begin\r
+ for i:=0 to list.Count-1 do begin\r
+ item:=TObject(list.items[i]) as TTP_RetranslatorItem;\r
+ if item.obj is TStrings then begin\r
+ // Since we don't know the order of items in sl, and don't have\r
+ // the original .Objects[] anywhere, we cannot anticipate anything\r
+ // about the current sl.Strings[] and sl.Objects[] values. We therefore\r
+ // have to discard both values. We can, however, set the original .Strings[]\r
+ // value into the list and retranslate that.\r
+ sl:=TStringList.Create;\r
+ try\r
+ sl.Text:=item.OldValue;\r
+ Instance.TranslateStrings(sl,textdomain);\r
+ (item.obj as TStrings).BeginUpdate;\r
+ try\r
+ (item.obj as TStrings).Text:=sl.Text;\r
+ finally\r
+ (item.obj as TStrings).EndUpdate;\r
+ end;\r
+ finally\r
+ FreeAndNil (sl);\r
+ end;\r
+ end else begin\r
+ newValue:=instance.dgettext(textdomain,item.OldValue);\r
+ {$ifdef DELPHI5OROLDER}\r
+ SetStrProp(item.obj, item.PropName, newValue);\r
+ {$endif}\r
+ {$ifndef DELPHI5OROLDER}\r
+ ppi:=GetPropInfo(item.obj, item.Propname);\r
+ if ppi<>nil then begin\r
+ SetWideStrProp(item.obj, ppi, newValue);\r
+ end else begin\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName);\r
+ {$endif}\r
+ end;\r
+ {$endif}\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure TTP_Retranslator.Remember(obj: TObject; PropName: String;\r
+ OldValue: WideString);\r
+var\r
+ item:TTP_RetranslatorItem;\r
+begin\r
+ item:=TTP_RetranslatorItem.Create;\r
+ item.obj:=obj;\r
+ item.Propname:=Propname;\r
+ item.OldValue:=OldValue;\r
+ list.Add(item);\r
+end;\r
+\r
+{ TGnuGettextComponentMarker }\r
+\r
+destructor TGnuGettextComponentMarker.Destroy;\r
+begin\r
+ FreeAndNil (Retranslator);\r
+ inherited;\r
+end;\r
+\r
+{ THook }\r
+\r
+constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);\r
+{ Idea and original code from Igor Siticov }\r
+{ Modified by Jacques Garcia Vazquez and Lars Dybdahl }\r
+begin\r
+ {$ifndef CPU386}\r
+ 'This procedure only works on Intel i386 compatible processors.'\r
+ {$endif}\r
+\r
+ oldproc:=OldProcedure;\r
+ newproc:=NewProcedure;\r
+\r
+ Reset (FollowJump);\r
+end;\r
+\r
+destructor THook.Destroy;\r
+begin\r
+ Shutdown;\r
+ inherited;\r
+end;\r
+\r
+procedure THook.Disable;\r
+begin\r
+ Assert (PatchPosition<>nil,'Patch position in THook was nil when Disable was called');\r
+ PatchPosition[0]:=Original[0];\r
+ PatchPosition[1]:=Original[1];\r
+ PatchPosition[2]:=Original[2];\r
+ PatchPosition[3]:=Original[3];\r
+ PatchPosition[4]:=Original[4];\r
+end;\r
+\r
+procedure THook.Enable;\r
+begin\r
+ Assert (PatchPosition<>nil,'Patch position in THook was nil when Enable was called');\r
+ PatchPosition[0]:=Patch[0];\r
+ PatchPosition[1]:=Patch[1];\r
+ PatchPosition[2]:=Patch[2];\r
+ PatchPosition[3]:=Patch[3];\r
+ PatchPosition[4]:=Patch[4];\r
+end;\r
+\r
+procedure THook.Reset(FollowJump: boolean);\r
+var\r
+ offset:integer;\r
+ {$ifdef LINUX}\r
+ p:pointer;\r
+ pagesize:integer;\r
+ {$endif}\r
+ {$ifdef MSWindows}\r
+ ov: cardinal;\r
+ {$endif}\r
+begin\r
+ if PatchPosition<>nil then\r
+ Shutdown;\r
+\r
+ patchPosition := OldProc;\r
+ if FollowJump and (Word(OldProc^) = $25FF) then begin\r
+ // This finds the correct procedure if a virtual jump has been inserted\r
+ // at the procedure address\r
+ Inc(Integer(patchPosition), 2); // skip the jump\r
+ patchPosition := pChar(Pointer(pointer(patchPosition)^)^);\r
+ end;\r
+ offset:=integer(NewProc)-integer(pointer(patchPosition))-5;\r
+\r
+ Patch[0] := char($E9);\r
+ Patch[1] := char(offset and 255);\r
+ Patch[2] := char((offset shr 8) and 255);\r
+ Patch[3] := char((offset shr 16) and 255);\r
+ Patch[4] := char((offset shr 24) and 255);\r
+\r
+ Original[0]:=PatchPosition[0];\r
+ Original[1]:=PatchPosition[1];\r
+ Original[2]:=PatchPosition[2];\r
+ Original[3]:=PatchPosition[3];\r
+ Original[4]:=PatchPosition[4];\r
+\r
+ {$ifdef MSWINDOWS}\r
+ if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then\r
+ RaiseLastOSError;\r
+ {$endif}\r
+ {$ifdef LINUX}\r
+ pageSize:=sysconf (_SC_PAGE_SIZE);\r
+ p:=pointer(PatchPosition);\r
+ p:=pointer((integer(p) + PAGESIZE-1) and not (PAGESIZE-1) - pageSize);\r
+ if mprotect (p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then\r
+ RaiseLastOSError;\r
+ {$endif}\r
+end;\r
+\r
+procedure THook.Shutdown;\r
+begin\r
+ Disable;\r
+ PatchPosition:=nil;\r
+end;\r
+\r
+procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);\r
+begin\r
+ HookLoadResString.Reset (SupportPackages);\r
+ HookLoadStr.Reset (SupportPackages);\r
+ HookFmtLoadStr.Reset (SupportPackages);\r
+ if enabled then begin\r
+ HookLoadResString.Enable;\r
+ HookLoadStr.Enable;\r
+ HookFmtLoadStr.Enable;\r
+ end;\r
+end;\r
+\r
+{ TMoFile }\r
+\r
+function TMoFile.autoswap32(i: cardinal): cardinal;\r
+var\r
+ cnv1, cnv2:\r
+ record\r
+ case integer of\r
+ 0: (arr: array[0..3] of byte);\r
+ 1: (int: cardinal);\r
+ end;\r
+begin\r
+ if doswap then begin\r
+ cnv1.int := i;\r
+ cnv2.arr[0] := cnv1.arr[3];\r
+ cnv2.arr[1] := cnv1.arr[2];\r
+ cnv2.arr[2] := cnv1.arr[1];\r
+ cnv2.arr[3] := cnv1.arr[0];\r
+ Result := cnv2.int;\r
+ end else\r
+ Result := i;\r
+end;\r
+\r
+function TMoFile.CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;\r
+var pc:^Cardinal;\r
+begin\r
+ inc (baseptr,offset);\r
+ pc:=Pointer(baseptr);\r
+ Result:=pc^;\r
+ if doswap then\r
+ autoswap32(Result);\r
+end;\r
+\r
+constructor TMoFile.Create(filename: string; Offset,Size:int64);\r
+var\r
+ i:cardinal;\r
+ nn:integer;\r
+ {$ifdef linux}\r
+ mofile:TFileStream;\r
+ {$endif}\r
+begin\r
+ if sizeof(i) <> 4 then\r
+ raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');\r
+\r
+ {$ifdef mswindows}\r
+ // Map the mo file into memory and let the operating system decide how to cache\r
+ mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);\r
+ if mo=INVALID_HANDLE_VALUE then\r
+ raise EGGIOError.Create ('Cannot open file '+filename);\r
+ momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);\r
+ if momapping=0 then\r
+ raise EGGIOError.Create ('Cannot create memory map on file '+filename);\r
+ momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0);\r
+ if momemoryHandle=nil then begin\r
+ raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);\r
+ end;\r
+ momemory:=momemoryHandle+offset;\r
+ {$endif}\r
+ {$ifdef linux}\r
+ // Read the whole file into memory\r
+ mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);\r
+ try\r
+ if size=0 then\r
+ size:=mofile.Size;\r
+ Getmem (momemoryHandle,size);\r
+ momemory:=momemoryHandle;\r
+ mofile.Seek(offset,soFromBeginning);\r
+ mofile.ReadBuffer(momemory^,size);\r
+ finally\r
+ FreeAndNil (mofile);\r
+ end;\r
+ {$endif}\r
+\r
+ // Check the magic number\r
+ doswap:=False;\r
+ i:=CardinalInMem(momemory,0);\r
+ if (i <> $950412DE) and (i <> $DE120495) then\r
+ EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);\r
+ doswap := (i = $DE120495);\r
+\r
+\r
+ // Find the positions in the file according to the file format spec\r
+ CardinalInMem(momemory,4); // Read the version number, but don't use it for anything.\r
+ N:=CardinalInMem(momemory,8); // Get string count\r
+ O:=CardinalInMem(momemory,12); // Get offset of original strings\r
+ T:=CardinalInMem(momemory,16); // Get offset of translated strings\r
+\r
+ // Calculate start conditions for a binary search\r
+ nn := N;\r
+ startindex := 1;\r
+ while nn <> 0 do begin\r
+ nn := nn shr 1;\r
+ startindex := startindex shl 1;\r
+ end;\r
+ startindex := startindex shr 1;\r
+ startstep := startindex shr 1;\r
+end;\r
+\r
+destructor TMoFile.Destroy;\r
+begin\r
+ {$ifdef mswindows}\r
+ UnMapViewOfFile (momemoryHandle);\r
+ CloseHandle (momapping);\r
+ CloseHandle (mo);\r
+ {$endif}\r
+ {$ifdef linux}\r
+ FreeMem (momemoryHandle);\r
+ {$endif}\r
+ inherited;\r
+end;\r
+\r
+function TMoFile.gettext(const msgid: ansistring;var found:boolean): ansistring;\r
+var\r
+ i, step: cardinal;\r
+ offset, pos: cardinal;\r
+ CompareResult:integer;\r
+ msgidptr,a,b:PChar;\r
+ abidx:integer;\r
+ size, msgidsize:integer;\r
+begin\r
+ found:=false;\r
+ msgidptr:=PChar(msgid);\r
+ msgidsize:=length(msgid);\r
+\r
+ // Do binary search\r
+ i:=startindex;\r
+ step:=startstep;\r
+ while true do begin\r
+ // Get string for index i\r
+ pos:=O+8*(i-1);\r
+ offset:=CardinalInMem (momemory,pos+4);\r
+ size:=CardinalInMem (momemory,pos);\r
+ a:=msgidptr;\r
+ b:=momemory+offset;\r
+ abidx:=size;\r
+ if msgidsize<abidx then\r
+ abidx:=msgidsize;\r
+ CompareResult:=0;\r
+ while abidx<>0 do begin\r
+ CompareResult:=integer(byte(a^))-integer(byte(b^));\r
+ if CompareResult<>0 then\r
+ break;\r
+ dec (abidx);\r
+ inc (a);\r
+ inc (b);\r
+ end;\r
+ if CompareResult=0 then \r
+ CompareResult:=msgidsize-size;\r
+ if CompareResult=0 then begin // msgid=s\r
+ // Found the msgid\r
+ pos:=T+8*(i-1);\r
+ offset:=CardinalInMem (momemory,pos+4);\r
+ size:=CardinalInMem (momemory,pos);\r
+ SetString (Result,momemory+offset,size);\r
+ found:=True;\r
+ break;\r
+ end;\r
+ if step=0 then begin\r
+ // Not found\r
+ Result:=msgid;\r
+ break;\r
+ end;\r
+ if CompareResult<0 then begin // msgid<s\r
+ if i < 1+step then\r
+ i := 1\r
+ else\r
+ i := i - step;\r
+ step := step shr 1;\r
+ end else begin // msgid>s\r
+ i := i + step;\r
+ if i > N then\r
+ i := N;\r
+ step := step shr 1;\r
+ end;\r
+ end;\r
+end;\r
+\r
+// DELPHI4\r
+\r
+function GetPropInfo(Instance: TObject; const Name: string; var PropInfo: TPropInfo): Boolean;\r
+var\r
+ Props: PPropList;\r
+ TypeData: PTypeData;\r
+ Info: PPropInfo;\r
+ i: Integer;\r
+begin\r
+ TypeData := GetTypeData(Instance.ClassInfo);\r
+ if ((TypeData <> nil) and (TypeData^.PropCount > 0)) then\r
+ begin\r
+ GetMem(Props, TypeData^.PropCount * sizeof(Pointer));\r
+ try\r
+ GetPropInfos(Instance.ClassInfo, Props);\r
+ for i := 0 to TypeData.PropCount - 1 do\r
+ begin\r
+ Info := Props[i];\r
+ if (AnsiCompareText(Info.Name, Name) = 0) then\r
+ begin\r
+ PropInfo := Info^;\r
+ Result := True;\r
+ Exit;\r
+ end\r
+ end;\r
+ finally\r
+ FreeMem(Props);\r
+ end;\r
+ end;\r
+ Result := False;\r
+end;\r
+\r
+function GetStrProp(Instance: TObject; Info: PPropInfo): string;\r
+begin\r
+ Result := TypInfo.GetStrProp(Instance, Info);\r
+end;\r
+\r
+function GetStrProp(Instance: TObject; const Name: string): string;\r
+var\r
+ Info: TPropInfo;\r
+begin\r
+ if GetPropInfo(Instance, Name, Info) then\r
+ Result := TypInfo.GetStrProp(Instance, @Info)\r
+ else\r
+ Result := '';\r
+end;\r
+\r
+procedure SetStrProp(Instance: TObject; const Name, Value: string);\r
+var\r
+ Info: TPropInfo;\r
+begin\r
+ if GetPropInfo(Instance, Name, Info) then\r
+ SetStrProp(Instance, @Info, Value);\r
+end;\r
+\r
+procedure SetStrProp(Instance: TObject; Info: PPropInfo; const Value: string);\r
+begin\r
+ TypInfo.SetStrProp(Instance, Info, Value);\r
+end;\r
+\r
+initialization\r
+ {$ifdef DXGETTEXTDEBUG}\r
+ {$ifdef MSWINDOWS}\r
+ MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK);\r
+ {$endif}\r
+ {$ifdef LINUX}\r
+ writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');\r
+ {$endif}\r
+ {$endif}\r
+ if IsLibrary then begin\r
+ // Get DLL/shared object filename\r
+ SetLength (ExecutableFilename,300);\r
+ {$ifdef MSWINDOWS}\r
+ SetLength (ExecutableFilename,GetModuleFileName(HInstance, PChar(ExecutableFilename), length(ExecutableFilename)));\r
+ {$else}\r
+ // This line has not been tested on Linux, yet, but should work.\r
+ SetLength (ExecutableFilename,GetModuleFileName(0, PChar(ExecutableFilename), length(ExecutableFilename)));\r
+ {$endif}\r
+ end else\r
+ ExecutableFilename:=Paramstr(0);\r
+ FileLocator:=TFileLocator.Create;\r
+ FileLocator.Analyze;\r
+ ResourceStringDomainList:=TStringList.Create;\r
+ ResourceStringDomainList.Add(DefaultTextDomain);\r
+ ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r
+ DefaultInstance:=TGnuGettextInstance.Create;\r
+ {$ifdef MSWINDOWS}\r
+ Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);\r
+ {$endif}\r
+\r
+ // replace Borlands LoadResString with gettext enabled version:\r
+ HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA);\r
+ HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr);\r
+ HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr);\r
+ HookIntoResourceStrings (AutoCreateHooks,false);\r
+\r
+finalization\r
+ FreeAndNil (DefaultInstance);\r
+ FreeAndNil (ResourceStringDomainListCS);\r
+ FreeAndNil (ResourceStringDomainList);\r
+ FreeAndNil (HookFmtLoadStr);\r
+ FreeAndNil (HookLoadStr);\r
+ FreeAndNil (HookLoadResString);\r
+ FreeAndNil (FileLocator);\r
+\r
+end.\r
+\r
projects / gpsbabel.git / commitdiff